صفحه ها
دسته
وبلاگ من در بلاگفا
عکس من
وبلاگهاي دوستان
ورودي هاي پنجره اميد
معرفي وب سايت هاي پرطرفدار
سايتهاي دوستان
لينك هاي دسترسي سريع
مطالب من در ثبت مطالب روزانه
آرشیو
آمار وبلاگ
تعداد بازدید : 575178
تعداد نوشته ها : 1492
تعداد نظرات : 394
Rss
طراح قالب
مهدي يوسفي
برنامه های سه بعدی از فضا نمی آیند توسط همین وی بی -دلفی واکثرآ سی پلاس پلاس طراحی می شن وقتی یک بازی سه بعدی روباز می کنیم ویک دفعه یک صفحه با گرافیکی که تا حالا ندیدیم یه صورت زیبا بالا می آد اکثر ما -بیشتر خودم- خیلی کف میکنیم که این برنامه ها چطور ساخته می شن-با چی ساخته می شن

امروز می خوام تنظیم ابعاد صفحه نمایش ویندوز رو با ابعاد دلخواه خودمون بگم که گام اول طراحی سه بعدیه اگه بشه شاید مراحل بعدیش رو هم بزارم روی سایت که مونده به یاری شما .بانظراتتون و خدا با توفیقش

ابتدا متغییر های اول فرم

Dim Dx As New DirectX7
Dim Dd As DirectDraw4
Dim clip As DirectDrawClipper

البته بعد از نوشتن کد بالا به منوی پروژه رفته گزینه ریفرنس رو انتخاب کنید در منوی باز شده تیک گزینه ی دایرکت ایکس 7 رو بزنید

تا کد هاتون اجرا بشه روی فرم دابل کلاک کنید و کد زیر رو بنویسید

Set Dd = Dx.DirectDraw4Create("")
Set clip = Dd.CreateClipper(0)
clip.SetHWnd Me.hWnd
' screen mode
Dd.SetDisplayMode 800, 600, 32, 0, DDSDM_DEFAULT

بااین کد صفحه نمایش به مد 800*600و حالت 32بایتی میره
پنج شنبه بیست و ششم 10 1387
کلاس یک مجموعه ای از کدهاست که شبیه به یک کنترل هستند فقط شکل ظاهری و طراحی ندارند
کلاس ها شی هستند - یعنی خاصیت دارند -کلاس ها می توانند داخل خود پردازه یا تابع محلی وسراسری داشته باشند
کلاس به چه دردی می خورد-کلاسها از تکرار کدها جلو گیری می کنند -کلاس ها خوانایی برنامه را افزایش می دهندوغیره
کلاس ها می توانند به صورت خودکار خود را مقدار دهی کنند-یک ماژول کلاس ایجاد کنید وکدهای زیر را در آن کپی کنید

تعریف یک خاصیت در کلاس

'-----------Set Property Information---------

Public Poperty Let CWidth( Value As Integer)
CWidth=Value
End Property

'------------Get Property Information--------------

Public Property Get CWidth() As Integer
CWidth=CForm.Width
End Property

دستور اول خاصیت را مقدار دهی می کند با مقداری که کار بر فرستاده
دستور دوم برای دادن مقدار برای کابر است .البته هر کدام از این دستورات را می توان به صورت محلی استفاده کرد
وی بی با کلاس ها مانند یک نوع جدید رفتار می کند یعنی شما برای استفاده از یک کلاس در سطح فرم باید یک متغیر از
نوع کلاس تعریف کنید .تعرف یک متغییر محلی در سطح فرم

Private CForm As Form

تمام متغییر ها وتوابع وپردازه ها وحتی نام خود کلاس را با سی آغاز کنید تا معلوم شود مربوط به یک کلاس است
تعرف یک پردازه سراسری در کلاس

Private Sub CSetInfo(Frm As Form)
Set Form=Frm
End Sub

اگر تمام کدها بالا را درست در یک ماژول کلاس کپی کنید اکنون نوبت استفاده از کدهای بالاست
در خط اول فرم یک متغییر از نوع نام کلاس تعریف کنید.بدین صورت

Dim Calss As Class1
Private Sub Form_Resiz()
Me.Caption="Form1.Width: "& Class.With
End Sub
پنج شنبه بیست و ششم 10 1387
کوتاهترین راه برای ساخت یک ساعت روش زیر است یک Picturebox به فرم اضافه کنید

Private Sub Form_Load()
Static Score As Long
Counter.Show
DoEvents
Score = 0
For I = 1 To 1265
DisplayNumber 10, Score
Score = I
DoEvents
Next
End Sub'-------------------------------------------------------------------
Private Sub DisplayNumber(DisplayWidth As Integer, TheNumber As Long)
Dim DisplayString As String, Zeros As Integer, GraphicsHeight As Single
Dim DigitValue As Integer, NumPosition As Integer
'--------------------Start Time---------------
GraphicsHeight = Picture1.ScaleHeight / 2
Zeros = DisplayWidth - Len(Trim(TheNumber))
For I = 0 To Zeros - 1
DisplayString = DisplayString & "0"
Next
DisplayString = DisplayString & Trim(Str(TheNumber))
For I = 0 To DisplayWidth - 1
DigitValue = Val(Mid(DisplayString, I + 1, 1))
If DigitValue = 0 Then NumPosition = 10 Else NumPosition = DigitValue _
Counter.PaintPicture Picture1.Image, I * (Picture1.ScaleWidth / 10), 0, _
Picture1.ScaleWidth / 10, Picture1.ScaleHeight / 2, (NumPosition - 1) _
* (Picture1.ScaleWidth / 10), GraphicsHeight, Picture1.ScaleWidth / 10, Picture1.ScaleHeight / 2
Next
End Sub

در کد بالا به دلایلی فرم خارج نمی شود باید یک دکمه برای خروج از فرم تنظیم کنیدودر کد کلیک آن بنوسید
End
پنج شنبه بیست و ششم 10 1387
On Error GoTo B
Dim r%, F%, Heght%, Wath%, X%, Color$ '--\/\/\/ Set Color Of Form
Color = "Red_Black" '----------------تعیین تیف رنگ
Heigh = Me.Height + 200: Widt = Me.Width
F = Heigh \ 255: r = 0
Select Case Color
Case "Red_Black": GoTo 1
Case "With_Red": GoTo 2
Case "Green_Black": GoTo 3
Case "With_Green": GoTo 4
Case "Blue_Black": GoTo 5
Case "With_Blue": GoTo 6
Case "With_Black": GoTo 7
End Select
Exit Sub '---------------------------Main--------------------------------------------
1
For i = 0 To Heigh Step F
r = r + 1
If r = 20000 Then Exit For
For X = i To F + i
Me.Line (0, X)-(Widt, X), RGB(250 - r, 0, 0)
Next X
Next i: GoTo B
2 '--------------------------------------------------------------------------------
For i = 0 To Heigh Step F
r = r + 1
If r = 20000 Then Exit For
For X = i To F + i
Me.Line (0, X)-(Widt, X), RGB(250, 254 - r, 255 - r)
Next X
Next i: GoTo B
3 '--------------------------------------------------------------------------------
For i = 0 To Heigh Step F
r = r + 1
If r = 20000 Then Exit For
For X = i To F + i
Me.Line (0, X)-(Widt, X), RGB(0, 250 - r, 0)
Next X
Next i: GoTo B
4 '--------------------------------------------------------------------------------
For i = 0 To Heigh Step F
r = r + 1
If r = 20000 Then Exit For
For X = i To F + i
Me.Line (0, X)-(Widt, X), RGB(250 - r, 255, 255 - r)
Next X
Next i: GoTo B
5 '--------------------------------------------------------------------------------
For i = 0 To Heigh Step F
r = r + 1
If r = 255 Then Exit For
For X = i To F + i
Me.Line (0, X)-(Widt, X), RGB(0, 0, 250 - r)
Next X
Next i: GoTo B
6 '--------------------------------------------------------------------------------
For i = 0 To Heigh Step F
r = r + 1
If r = 20000 Then Exit For
For X = i To F + i
Me.Line (0, X)-(Widt, X), RGB(250 - r, 250 - r, 255)
Next X
Next i: GoTo B
7 '--------------------------------------------------------------------------------
For i = 0 To Heigh Step F
r = r + 1
If r = 9000 Then Exit For
For X = i To F + i
Me.Line (0, X)-(Widt, X), RGB(250 - r, 250 - r, 250 - r)
Next X
Next i '--------------------------------------------------------------------------------
B:
Set Me.Picture = Me.Image

میتونید این کد رو خیلی کوتاه استفاده کنید وهرخط چینی که مربوط به رنگ خودتونه رو نگه دارید بقیه رو حذف کنید.با کمی دقت می توانید رنگ های جدید بسازید
پنج شنبه بیست و ششم 10 1387
Private Declare Function SetPixelV Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Byte
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long

Private Sub CmdBrightness_Click()
'variables for brightness, color calculation, positioning
Dim Brightness As Single
Dim NewColor As Long
Dim x, y As Integer
Dim r, g, b As Integer
'change the brightness to a percent
Brightness = TxtBrightness / 100
'run a loop through the picture to change every pixel
For x = 0 To Picture1.ScaleWidth
For y = 0 To Picture1.ScaleHeight
'get the current color value
NewColor = GetPixel(Picture1.hDC, x, y)
'extract the R,G,B values from the long returned by GetPixel
r = (NewColor Mod 256)
b = (Int(NewColor / 65536))
g = ((NewColor - (b * 65536) - r) / 256)
'change the RGB settings to their appropriate brightness
r = r * Brightness
b = b * Brightness
g = g * Brightness
'make sure the new variables aren't too high or too low
If r > 255 Then r = 255
If r < 0 Then r = 0
If b > 255 Then b = 255
If b < 0 Then b = 0
If g > 255 Then g = 255
If g < 0 Then g = 0
'set the new pixel
SetPixelV Picture1.hDC, x, y, RGB(r, g, b)
'continue through the loop
Next y
'refresh the picture box every 10 lines (a nice progress bar effect)
If x Mod 10 = 0 Then Picture1.Refresh
Next x
'final picture refresh
Picture1.Refresh
End Sub

احتیاج دارید که متن درون آن به درصد برابر میزان روشنایی استTxtBrightnessیک کادر متن به نامCmdBrightnessحال کردین با توضیحات کامل برای کد بالا یک کامند به نام
پنج شنبه بیست و ششم 10 1387
این خط رو در اولین خط کد فرم بنویسید-برای مبتدی ها

Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long

طریقه استفاده
Private Sub Form_load()
Dim W, H
W = Screen.Width / 15
H = Screen.Height / 15
StretchBlt hdc, 0, 0, W, H, GetDC(0&), 0, 0, W, H, vbSrcCopy
End Sub

کشیدن یک دایره روی فرم با کد نویسی-نمودار دایره ای-بیضی
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
PI = 3.14159265
For i = 0 To 161 Step 10
Me.Circle (219, 167), i, RGB(0, 0, 0), 360 * (PI / 180), 360 * (PI / 180), 1
Next
End Sub

آنرا به 3 تغییر دهید.داشتم می گفتم پارامتر سوم برای شعاع دایره -اندازه آن-پارامتر چهارمscalmode توضیحات: پارامتر اول ودوم مکان ترسیم دایره اگر دایره در فرم شما رسم نشد خاصیت
برای رنگ پنجم برای نقطعه شروع وششم برای نقطه ی پایان این دو تا برای رسم نمودار دایره ای بکار می روند.پارامتر آخر هم برای رسم بیضی استفاده می شود

چگونه می توان یک مداد درست کرد مانند برنامه نقاشی ویندوز
کد زیر را در MouseMove بنویسید
If Button <> vbright Then Me.PSet (X, Y)

چطور می توان یک قطره چکان درست کرد که روی هر گزینه رفت رنگ پیش فرض رنگ انجا شود
عکس بنویسیدMouseMoveبه فرم اضافه کنید یک عکس داخل کادر عکس قرار دهید و کدزیر را در رویدادPictureویکLabelیک

Label1.BackColor=Picture1.Point(X,Y)

چطور می توان یک عکس را معکوس کرد
منظورت ازمعکوس اگه معکوس خود عکس در طراحی باشه کد زیر جوابش هست

With Picture1
.PaintPicture .Picture, 0, .Height, .Width, -.Height
End With

ولی اگه منظورت معکوس رنگ باشه کد زیر جوابش هست
With Picture1
.PaintPicture .Picture, 0, 0, , , , , , , vbDstInvert
End With

یرای موقعی به کار می رود که از یک اسم زیاداستفاده می کنیم.اسم را جلوی آن مینویسیم وهر وقت یک دات بزنیم قابل استفاده استWithتوضیحات:ِ
پارامتر اول یرای عکسی که میخواهیم از آن برای ترسیم استفاده کنیم.دوم و سوم برای نقطه شروع ترسیم .چهارم و پنجم برای اندازه تصویر ترسیمی.ششموهفتم برای نقطه پایان ترسیم.هشتم ونهم برای اندازه های پایانی ترسیم وپارامتر آخر برای نوع ترسیم
پنج شنبه بیست و ششم 10 1387
مبحث امروز که ارتباط داره به خواندن اطلاعات اساسی فایل MP3.متغییر های زیر رو تو اول کد تعریف کنید

Dim HasTag As Boolean
Dim Tagg As String * 3
Dim Songname As String * 30
Dim Artist As String * 30
Dim Album As String * 30
Dim Year As String * 4
Dim Comment As String * 30
Dim Genre As String * 1

البته کد بالا تست شده است مورد کاملش اینهاست ولی نمی دونم جواب بده یانه خودتون امتحان کنید اگه شد بهم بگید -فعلآ استفاده نکنید

Private Type MP3Tag
FullName As String ' Filename and filepath of MP3 file
FileName As String ' Name of MP3 file
Path As String ' Path of MP3 file
title As String * 30
artist As String * 30
album As String * 30
Year As String * 4
Comment As String * 30
Genre As String * 20
TagPresent As Boolean
MPEGVersion As String * 3 ' Version 1.0, 2.0 or 3.0
Layer As String * 1 ' Layer 1, 2 or 3
Protection As Boolean ' 0=CRC is present, 1=Not Protected
BitRate As String * 3 ' Recording bitrate
SampleRate As String * 5 ' Sampling Frequency
Padding As Integer ' 0=Frame is not padded, 1=(32bits for Layer 1, 8bits for Layer 2/3)
PrivateBit As Integer ' Not used. Do what you want with it
ChannelMode As String * 12 ' 00=Stereo, 01=Joint Stereo, 10=Dual Channel Stereo, 11=Mono
ModeExtension As String * 2 ' Used only for Joint Stereo
Copyright As Boolean ' Is file copyrighted?
Original As Boolean ' Is file on original media?
Emphasis As String * 8 ' Emphasis setting (usually none (00))
FrameLength As Integer ' Calculated from BitRate, SampleRate and Padding
TotalFrames As Long ' Filelength/Framelength
PlayTime As Single ' Calculated from TotalFrames, SampleRate and Stereo?
ValidHeader As Boolean ' True=Valid Header found, False=Not an MP3 file
End Type

بعد یک پروسیجر به این صورت تعریف می کنیم تاهر وقت بهش یک نام فایل پاس دادیم متغییر هامون پر بشه از اطلاعت فایل

Private Sub GetTag(Filename)
Open Filename For Binary As #1
Get #1, FileLen(Filename) - 127, Tagg
If Not Tagg = "TAG" Then
Close #1
HasTag = False
Songname = "No Tag Found"
Artist = "No Tag Found"
Album = "No Tag Found"
Year = "None"
Comment = "No Tag Found"
Genre = "0"
Exit Sub
End If
HasTag = True
Get #1, , Songname
Get #1, , Artist
Get #1, , Album
Get #1, , Year
Get #1, , Comment
Get #1, , Genre
Close #1
End Sub

حالا به این صورت میشه ازش استفاده کرد

Me.GetTag(MP3 FileName)

به طور معمول وقتی فایل به صورت باینری باز می شه چیزی جز صفر و یک رو نمشه از توش خواند به همین دلیل این نوع باز کردن فایل رو تصویر آینه وار حافظه می گن.چون هر چی روی هارد نوشته همون رو دودستی تحویلت می ده!از این رو باید همیشه بعد از خواندن این نوع فایل ها اونارو از فرمت باینری در آورد با تابع زیر که ازقبل توی وی بی هست

Src(Your Ascii Word)

اگه رشته رو با(String *30)ولی در برنامه بالا چون اندازه رشته رو تعریف کردیم

یک کد اسکی مقدار دهی کنیم خود به خود هنگام چاپ به فرم رشته ی معمولی در میاد

در دستور بالا ما با علامت ضربدر به وی بی می گوییم که چه مقدار حافظه را برای متغییر ما نگه دارد ولی اگر این مورد را استفاده نکنیم وی بی به صورت اتوماتیک سایز رشته رو انتخاب .میکنه اگه رشته کم باشه کم واگر زیاد باشه زیاد براش جا نگه می داره به ازای هر حرف یک بایت
پنج شنبه بیست و ششم 10 1387
کنترل WindowsMediaPlayer که توسط کتابخانه قدرتمندی پشتیبانی می شود را می توان در انواع ویندوز استفاده کرد

نحوه ی استفاده از کنترل. از منوی Components\WindowsMediaPlayer گزینه WindowsMediaPlayer را انتخاب کنید

قبل از اینکه آن کادر را ببندید MicrosoftCommonDialog را هم انتخاب کنید

یک دکمه قرار دهید و کد زیر را درونش وارد کنید

CommonDialog1.ShowOpen
WindowsMediaPlayer1.URL=CommDialog1.FileName

مشاهده می کنید که کادر فایل باز شده و فایل انتخاب شده پخش می شود

private sub Play_Click()
WindowsMediaPlayer1.Controls.Play()
End Sub

'------------------------
Prrivate Sub Stop_Click()
WindowsMediaPlayer1.Controls.Stop()
End Sub

'------------------------
Private Sub Pause_Click()
WindowsMediaPlayer1.Pause()
End Sub

یک تایمر به فرم اضافه کنید و یک HScroll1 و یک Lable
تایمر را به 50 تنظیم کنید.روی تایمر دوبار کلیک کنید وکد زیر را وارد کنید

Private sub Timer1_Timer()
Label1.Caption=WindowsMediaPlayer1.Controls.CurrentPositionString
HScroll1.max=WindowsMediaPlayer1.Controls.CurrentItem
HScrol1.Value=WindowsMediaPlayer1.Controls.CurrentPosition
End Sub
پنج شنبه بیست و ششم 10 1387
یک فرم ایجاد کنید و یه هفت تا لیبل بزارین روش با یه تایمر و یه HScroll
خاصیت Max مربوط به اسکرول رو روی 100 بزارین
خاصیت Interval تایمر رو روی 50 بزارین

این کدها رو اولین خط فرم بنویسید

'----------Type New Data For Memory------------------
Private Type MEMORYSTATUS
dwlength As Long
dwMemoryLoad As Long
dwTotalPhys As Long
dwAvailPhys As Long
dwTotalPageFile As Long
dwAvailPageFile As Long
dwTotalVirtual As Long
dwAvailVirtual As Long
End Type '------------------Declear API Of Kernal Windows Librery-------------
Private Declare Sub GlobalMemoryStatus Lib "KERNEL32" (lpBuffer As MEMORYSTATUS)
Dim Mem As MEMORYSTATUS

روی تایمر دابل کلیک کنید و کد زیر را بنویسید

GlobalMemoryStatus Mem
Me.Caption = Mem.dwMemoryLoad & "% used"
Label1.Caption = "Memory used: " & Mem.dwMemoryLoad & "%"
Label2.Caption = "Total Physical Memory: " & Mem.dwTotalPhys
Label3.Caption = "Available Physical Memory: " & Mem.dwAvailPhys
Label4.Caption = "Page File Bytes: " & Mem.dwTotalPageFile
Label5.Caption = "Available bytes of Page File: " & Mem.dwAvailPageFile
Label6.Caption = "Total Virtual bytes: " & Mem.dwTotalVirtual
Label7.Caption = "Available Virtual Bytes: " & Mem.dwAvailVirtual
HScroll1.Value = Mem.dwMemoryLoad

با کدای بالا می تونین کارکرد CPU و RAM رو مشاهده کنید مثل خود ویندوز
پنج شنبه بیست و ششم 10 1387
چطور میتوان سطل آشغال ویندوز رو خالی کرد

اگه بخواید یک برنامه تقویت ویندوز بنویسید به گزینه خالی کردن سطل آشغال ویندوز نیاز خواهید داشت
سری قبل این اموزش رو در مورد کنترل سی پی یو (تاکس منیگر)ویندوز نوشتم
برای این کار باید از تابعی موجود در کتابخانه قدرتمند شل که در آرشیو اموزشهای زیادی راجع به این کتابخانه هست استفاده کنید

شیوه ی تعریف کتابخانه

Private Declare Function SHEmptyRecycleBin Lib "shell32.dll" Alias "SHEmptyRecycleBinA" (ByVal hWnd As Long, ByVal pszRootPath As String, ByVal dwFlags As Long) As Long
Const SHERB_NOPROGRESSUI = &H2

شیوه ی استفاده

Private Sub Command1_Click()
Dim retvaL
retvaL = SHEmptyRecycleBin(Form1.hWnd, "", SHERB_NOPROGRESSUI)
End Sub
پنج شنبه بیست و ششم 10 1387
کادر خصوصیات اکثرآ در نوشتن یک کاد آرشیو یا لیست فایل کاربرد دارد که شما روی نام فایل راست کلیک می کنید و این گزینه را معمولآ در انتهای لیست انتخاب می کنید واین کادر ظاهر میشود نوشتن چنین کد هایی باعث حرفه شدن برنامه ی شما می گردد

به ماژولمان کد های زیر را اضافه کنید

'------Typing New data For Propertis File---------------------
Type SHELLEXECUTEINFO
cbSize As Long
fMask As Long
hwnd As Long
lpVerb As String
lpFile As String
lpParameters As String
lpDirectory As String
nShow As Long
hInstApp As Long
lpIDList As Long
lpClass As String
hkeyClass As Long
dwHotKey As Long
hIcon As Long
hProcess As Long
End Type
'---------------Conset For Propertis Dialog-------------------
Public Const SEE_MASK_INVOKEIDLIST = &HC
Public Const SEE_MASK_NOCLOSEPROCESS = &H40
Public Const SEE_MASK_FLAG_NO_UI = &H400
Public Const ATTR_NORMAL = 0
Public Const ATTR_READONLY = 1
Public Const ATTR_HIDDEN = 2
Public Const ATTR_SYSTEM = 4
Public Const ATTR_VOLUME = 8
Public Const ATTR_DIRECTORY = 16
Public Const ATTR_ARCHIVE = 32
'-----------------------Declareing API------------------------------------------
Declare Function ShellExecuteEX Lib "shell32.dll" Alias _
"ShellExecuteEx" (SEI As SHELLEXECUTEINFO) As Long

'-----------------------------------------------------------------------------------------

Public Function ShowFileProperties(filename As String, OwnerhWnd As Long) As Long
Dim SEI As SHELLEXECUTEINFO
With SEI
.cbSize = Len(SEI)
.fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_INVOKEIDLIST Or SEE_MASK_FLAG_NO_UI
.hwnd = OwnerhWnd
.lpVerb = "properties"
.lpFile = filename
.lpParameters = vbNullChar
.lpDirectory = vbNullChar
.nShow = 0
.hInstApp = 0
.lpIDList = 0
End With
ShellExecuteEX SEI
ShowFileProperties = SEI.hInstApp
End Function

حالا هر فایلی را که می خواهید خصوصییاتش نمایش داد شود به این تابع به صورت زیر ارسال کنید-پاس دهید

ShowFileProperties(FileName,Me.hwn
پنج شنبه بیست و ششم 10 1387
این کادر استفاده ی بسیار زیادی در برنامه های کاربردی داره.وموقعی استفاده می شه که کار بر باید یک پوشه رو (مثلآ برای نصب برنامه )انتخاب کنه
یک ماژول ایجاد کنید و کد های زبر رابنویسید

'------Typing New data For BrowsForm---------------------
Public Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type

'---------------Conset For BrowsForm--------------------
Public Const BIF_RETURNONLYFSDIRS = 1
Public Const BIF_DONTGOBELOWDOMAIN = 2
Public Const MAX_PATH = 260

'-----------------------Declareing API------------------------------------------
Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long

حال در جایی که می خواهید کادر ظاهر شود کد زیر رابنویسید

Dim lpIDList As Long
Dim sBuffer As String
Dim szTitle As String
Dim tBrowseInfo As BrowseInfo
szTitle = "Select Folder... "
With tBrowseInfo
.hWndOwner = Me.hwnd
.lpszTitle = lstrcat(szTitle, "")
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
End With
lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
msgbox( sBuffer)
End If

در پایان خط م اقبل آخر با یک پیغام مسیر انتخاب شده کاربر اعلام می شود که شما عزیزان می توانید آنرا به دلخواه تغییر دهید
پنج شنبه بیست و ششم 10 1387
اموزش یک کار جالب با فرم ها
تنها با دو خط کد میتونید جلوه ای رو بوجود بیارید که فکرشم نمی کردید. یک فرم رو توی یک فرم دیگه جابدید. استفاده های زیادی میشه ازش کرد. مثلا ساخت نوار ابزارهایی مثل اونی که فتوشاپ داره. راجع بهش فکر کنید
این هم کدش

Private Declare Function SetParent Lib "user32" ( _
ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long

Private Sub Form_Load()
SetParent Form2.hWnd, hWnd
Form2.Show
End Sub
پنج شنبه بیست و ششم 10 1387
اول فراخوانی توابع

Option Explicit
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long

بعد سه تا کامند برای ظاهر کردن آیکون ها مخفی کردن آنها و خروج از فرم بنویسید

کد هر کدام اینطور است

Private Sub cmdDHide_Click()
Dim hWnd As Long
hWnd = FindWindowEx(0&, 0&, "Progman", vbNullString)
ShowWindow hWnd, 0
End Sub'--------------------------------
Private Sub cmdDShow_Click()
Dim hWnd As Long
hWnd = FindWindowEx(0&, 0&, "Progman", vbNullString)
ShowWindow hWnd, 5
End Sub'---------------------------------
Private Sub cmdExit_Click()
Me.Hide
End
End Sub'-------------------------------------
پنج شنبه بیست و ششم 10 1387
این کد رو هم توی پروژه دیگه تست کنید - تاریخ فارسی

MsgBox WeekdayName(Weekday(Date), False, vbSunday) & ", " & VBA.MonthName(VBA.Month(Date)) & " " & Day(Date) & ", " & VBA.Year(Date), vbOKOnly + vbInformation, "The date
پنج شنبه بیست و ششم 10 1387
البته حتما باید سریع به حالت قبل برگردونید چون موندن این حالت زیاد جالب نیست

Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" _
(ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long

Private Const SPI_SCREENSAVERRUNNING = 97

حالا دو تا کامند به فرم اضافه کنید به اسم های Desabled و Enabled

کد دکمه غیر فعال کردن

Private Sub Disabled_Click()
Dim Ret As Long
Dim pOld As Boolean
Ret = SystemParametersInfo(SPI_SCREENSAVERRUNNING, True, pOld, 0)
End Sub

کد فعال سازی این کلید ها بهتر است این کدها را در Unload فرم نیز فراخوانی کنید

Private Sub EnableD_Click()
Dim Ret As Long
Dim pOld As Boolean
Ret = SystemParametersInfo(SPI_SCREENSAVERRUNNING, False, pOld, 0)
End Sub
پنج شنبه بیست و ششم 10 1387
چطور می شه دکمه بستن پنجره در گوشه فرم رو غیر فعال کرد
شاید غیر فعال کرد دکمه های تمام صفحه و کمینه رو بلد باشین ولی
دیگه فرم خاصیت غیر فعال کردن دکمه close رو نداره مگه کنترل بوکس فرم رو
برداریم یا اصلآ فرم رو از نوع بدون منوی بالا وتیتر انتخاب کنیم
ولی با این کد می تونین با داشتن تمام کنترل ها فقط دکمه کلوز رو غیر فعال کنین
تابع زیر رو تعریف کنید

Public Const SC_CLOSE = &HF060
Public Const MF_BYCOMMAND = &H0
Public Declare Function GetSystemMenu Lib "user32" _
(ByVal hwnd As Long, ByVal bRevert As Long) As Long
Public Declare Function DeleteMenu Lib "user32" _
(ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long

Public Sub DisableXbutton(ByVal frmHwnd As Long)
Dim hMenu As Long
hMenu = GetSystemMenu(frmHwnd, 0&)
If hMenu Then
Call DeleteMenu(hMenu, SC_CLOSE, MF_BYCOMMAND)
DrawMenuBar (frmHwnd)
End If
End Sub

حالا کد زیر رو داخل Form_Load بنویسید

DisableXbutton (Me.hwnd)
پنج شنبه بیست و ششم 10 1387
مخفی کردن منوی Start
برای مخفی کردن منوی Start به یک تابع از کتابخانه user32.dll احتیاج دارید

Option Explicit

Dim hwnd1 As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, _
ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Const SWP_HIDEWINDOW = &H80
Const SWP_SHOWWINDOW = &H40

حالا باید دو تا دکمه برای مخفی و آشکار کردن منوی Startبه فرم اضافه کنید

کد مخفی کردن Start
Hwnd1=FindWindow("Shell_traywnd","")
call SetWindowPos(Hwnd1,0,0,0,0,0,SWP_HIDEWINDOW)

کد ظاهر کردن Start
call SetWindowPos(Hwnd1,0,0,0,0,0,SWP_SHOWWINDOW)

*****************************
آیکون یک برنامه رو از کالبدش کشید بیرون و به صورت فایل آیکون ذخیره کرد
این آموزش از سری آموزشی کتابخانه قدرتمند Shell هست
یک ماژول به پروژه اضافه کنید و کد زیر را داخلش کپی کنید

Public Const MAX_PATH = 260
Public Const SHGFI_DISPLAYNAME = &H200
Public Const SHGFI_EXETYPE = &H2000
Public Const SHGFI_SYSICONINDEX = &H4000 ' System icon index
Public Const SHGFI_LARGEICON = &H0 ' Large icon
Public Const SHGFI_SMALLICON = &H1 ' Small icon
Public Const ILD_TRANSPARENT = &H1 ' Display transparent
Public Const SHGFI_SHELLICONSIZE = &H4
Public Const SHGFI_TYPENAME = &H400
Public Const BASIC_SHGFI_FLAGS = SHGFI_TYPENAME _
Or SHGFI_SHELLICONSIZE Or SHGFI_SYSICONINDEX _
Or SHGFI_DISPLAYNAME Or SHGFI_EXETYPE

Public Type SHFILEINFO
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type

Public Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" _
(ByVal pszPath As String, _
ByVal dwFileAttributes As Long, _
psfi As SHFILEINFO, _
ByVal cbSizeFileInfo As Long, _
ByVal uFlags As Long) As Long

Public Declare Function ImageList_Draw Lib "comctl32.dll" _
(ByVal himl&, ByVal i&, ByVal hDCDest& _
,ByVal x&, ByVal y&, ByVal flags&) As Long
Public shinfo As SHFILEINFO

یه دکمه به برنامه اضافه کنید و یک texbox و با دو تا picbox و دو تا برچسب
و اینکه نام picbox ها رو image1 و image2 قرار بدهید
آدرس فایل اجرایی را داخل texbox بنویسید و در کد کلیک دکمه کد زیر را بنویسید

Dim hImgSmall As Long
Dim hImgLarge As Long
Dim FileName As String
Dim r As Long

FileName$ = Text1.Text
hImgSmall& = SHGetFileInfo(FileName$, 0&, shinfo, Len(shinfo), BASIC_SHGFI_FLAGS Or SHGFI_SMALLICON)
hImgLarge& = SHGetFileInfo(FileName$, 0&, shinfo, Len(shinfo), BASIC_SHGFI_FLAGS Or SHGFI_LARGEICON)
Label1.Caption = Left$(shinfo.szDisplayName, InStr(shinfo.szDisplayName, Chr$(0)) - 1)
Label2.Caption = Left$(shinfo.szTypeName, InStr(shinfo.szTypeName, Chr$(0)) - 1)

image1.Picture = LoadPicture()
image2.Picture = LoadPicture()

r& = ImageList_Draw(hImgSmall&, shinfo.iIcon, image1.hDC, 0, 0, ILD_TRANSPARENT)
r& = ImageList_Draw(hImgLarge&, shinfo.iIcon, image2.hDC, 0, 0, ILD_TRANSPARENT
پنج شنبه بیست و ششم 10 1387
تا حالا دیدین کسی قلب خودش رو جلوی دیگران در بیاره
اما دیوید بلین جادوگر بزرگ امریکایی این کار رو کرد
http://www.ljava2.persiangig.com/audio/blaine.asf

برنامه ای که با آن می توان فایل اجرایی را باز کرد و سورسش را دید
http://www.hot.ee/microtools4u/Versions/SourceEditor.zip
کرکش
http://ar.yahoo.com/*http://64.233.98.43/e-Lunatic/15.08.Source.Editor.v2.26.zip

یک فرم MDI پیشرفته
http://www.pscode.com/vb/scripts/ShowZip.asp?lngWId=1&lngCodeId=57502&strZipAccessCode=tp%2F%5B575020912

یک برنامه جالب برای بزرگ نمایی روی Desktop
http://download.mehrzad.net/Default.aspx?ID=2
پنج شنبه بیست و ششم 10 1387
تبدیل رادیان به درجه

چون اکثر توابع مثلثاتی بر حسب رادیان کار می کنند گاهی اوقات نیاز داریم تا زوایا را از در جه به رادیان و بالعکس تبدیل کنیم. برای تبدیل یک زاویه بر حسب رادیان به درجه، آنرا در 180 ضرب کرده و سپس بر عدد پی تقسیم می‌کنیم:

Degree(x) = x * 180 / Pi
برای تبدیل یک زاویه بر حسب درجه به رادیان، آنرا در عدد پی ضرب کرده و سپس بر 180 تقسیم می‌کنیم:
Rad(x) = x * Pi / 180

*******************************
یک سری کدهای اماده ویژوال بیسیک براتون میزارم تا تمرین کنید

'frmtrst:
'give the nomber of numbers
'give n numbers
'get average

Option Explicit

Private Sub cmdcalculate_Click()
Dim totcount, totnum, ncount, inputno As Integer
Dim naver As Single
lbldisp.Caption = ""

totcount = Val(txtcount.Text)
Do While ncount < totcount
inputno = InputBox("Enter a no ", "input no")
ncount = ncount + 1
totnum = totnum + inputno
Loop
If totcount > 0 Then
naver = totnum / ncount
End If
lbldisp.Caption = "The average is " & naver
txtcount.Text = ""
End Sub

*******************************
'frm421
'10*10 stars
Option Explicit

Private Sub cmdstar_Click()
Dim i As Integer

For i = 1 To 100
Print "*";
If i Mod 10 = 0 Then
Print
End If
Next i

End Sub

*******************************
'frm0605
'the most little
Option Explicit

Private Sub cmdsmall_Click()
Dim val1 As Long, val2 As Long, val3 As Long
val1 = txtone.Text
val2 = txttwo.Text
val3 = txtthree.Text
Call minimum(val1, val2, val3)
End Sub

Private Sub minimum(min As Long, y As Long, z As Long)
If y < min Then
min = y
End If
If z < min Then
min = z
End If
lblsmall.Caption = "smallest value is " & min
End Sub

*******************************
'count & print even
'frm0703
Option Explicit

Private Sub cmdprint_Click()
Dim s(9) As Integer
Dim x As Integer
Cls
For x = LBound(s) To UBound(s)
s(x) = 2 + 2 * x
Next x
For x = LBound(s) To UBound(s)
Print Space$(2) & x & Space$(7) & s(x)
Next x
End Sub

*******************************
'frm0706
Option Explicit
Dim marray(-5 To 5) As Integer

Private Sub cmdarray_Click()
Dim x As Integer
Call initialize
Call modifyarray(marray())
Call printmodified
End Sub

Private Sub cmdelement_Click()
Dim x As Integer
Call initialize
For x = LBound(marray) To UBound(marray)
Call modifyelement(marray(x))
Next x
Call printmodified
End Sub

Private Sub cmdexit_Click()
End
End Sub

Private Sub initialize()
Dim x As Integer
lstoriginal.Clear
lstmodified.Clear
For x = LBound(marray) To UBound(marray)
marray(x) = x
lstoriginal.AddItem marray(x)
Next x

End Sub
Private Sub printmodified()
Dim x As Integer
For x = LBound(marray) To UBound(marray)
lstmodified.AddItem marray(x)
Next x
End Sub

Private Sub modifyarray(a() As Integer)
Dim x As Integer
For x = LBound(a) To UBound(a)
a(x) = a(x) * 2
Next x
End Sub

Private Sub modifyelement(element As Integer)
element = element * 5
End Sub

*******************************
'frmboolean
Option Explicit

Private Sub cmdprint_Click()
Dim bool As Boolean
Dim x As Integer
x = -1
Print "x" & vbTab & "bool"
Do Until x = 10
bool = x
Print x & vbTab & bool
x = x + 1
Loop
Print
bool = True
Print bool
bool = False
Print bool
End Sub

*******************************

'frmsecurity
Option Explicit

Dim maccesscode As Long

Private Sub cmd3_Click()
txtdisplay.Text = txtdisplay.Text & "3"
End Sub

Private Sub cmd4_Click()
txtdisplay.Text = txtdisplay.Text & "4"
End Sub

Private Sub cmd5_Click()
txtdisplay.Text = txtdisplay.Text & "5"
End Sub

Private Sub cmd6_Click()
txtdisplay.Text = txtdisplay.Text & "6"
End Sub

Private Sub cmd7_Click()
txtdisplay.Text = txtdisplay.Text & "7"
End Sub

Private Sub cmd8_Click()
txtdisplay.Text = txtdisplay.Text & "8"
End Sub

Private Sub cmd9_Click()
txtdisplay.Text = txtdisplay.Text & "9"
End Sub

Private Sub cmdclear_Click()
txtdisplay.Text = ""
End Sub

Private Sub cmdenter_Click()
Dim message As String
lstlongentery.Clear
maccesscode = Val(txtdisplay.Text)
txtdisplay.Text = ""
Select Case maccesscode
Case Is < 1000
message = "Aceess Denied "
Beep
Case 1645 To 1689
message = "Technican personnel"
Case 8345
message = "Custodial Services"
Case 55875
message = "Special Services"
Case 999898, 1000006 To 1000008
message = "Scientific Personal"
Case Else
message = "Acess DEnied "
End Select

lstlongentery.AddItem Now & Space$(3) & message

End Sub

Private Sub cmdone_Click()
txtdisplay.Text = txtdisplay.Text & "1"
End Sub

Private Sub cmdzero_Click()
txtdisplay.Text = txtdisplay.Text & "0"
End Sub
Private Sub cmd2_Click()
txtdisplay.Text = txtdisplay.Text & "2"
End Sub

*******************************
'frmfig0614
Option Explicit

Private Sub cmddivide_Click()
Dim numerator As Integer, denominator As Integer
Dim result As String
numerator = txtnum.Text
denominator = txtden.Text
result = divide(numerator, denominator)
If result = "" Then
lblthree.Caption = "divide by zero"
Else
lblthree.Caption = result
End If

End Sub

Private Function divide(n As Integer, d As Integer) As String
If d = 0 Then
Exit Function
Print "after exit function "
Else
divide = "division yields " & n / d
End If

End Function

*******************************

'frmfig0310
Option Explicit
Dim sum As Integer
Private Sub cmdadd_Click()
sum = sum + txtinput.Text
txtinput.Text = ""
txtsum.Text = sum
End Sub

Private Sub cmdexit_Click()
End
End Sub

*******************************
'frmdraw
Option Explicit

Private Sub cmddraw_Click()
Dim side As Integer, row As Integer, column As Integer
side = txtinput.Text
Cls
If side <= 12 Then
If side > 0 Then
row = 1
While row <= side
column = 1
While column <= side
If row = 1 Or row = side Or column = 1 Or column = side Then

Print "<-PostContent->quot;;
Else
Print "&";
End If
column = column + 1
Wend
Print
row = row + 1
Wend

Else
Print "side too small "
Beep
End If
Else
Print "side too large "
Beep
End If
End Sub

*******************************
'frmdisplay
Option Explicit

Private Sub cmdprint_Click()
Dim counter As Integer
txtinput.SetFocus
counter = 0
counter = Val(txtinput.Text)
lbldisplay.Caption = ""
'txtinput.SetFocus
Do While counter > 0
lbldisplay.Caption = lbldisplay.Caption & "#"
counter = counter - 1
Loop
End Sub

*******************************
'frmcompund
Option Explicit

Private Sub cmdcal_Click()
Dim years As Integer
Dim interestrate As Double
Dim amount As Currency
Dim principal As Currency
lstdisplay.Clear
years = 10
principal = txtamount.Text
interestrate = txtinterest.Text / 100
lstdisplay.AddItem "year " & vbTab & "amount on deposit"
For years = 1 To 10
amount = principal * (1 + interestrate) ^ years
lstdisplay.AddItem Format$(years, "@@@@") & vbTab & Format$(Format$(amount, "currency"), _
String$(17, "@"))

Next years
End Sub

Private Sub cmdexit_Click()
End
End Sub
پنج شنبه بیست و ششم 10 1387
با این برنامه می تونین دو تا تصویر رو روی هم بندازید و حرکت بدین
تصاویرتون باید JPG باشه و بزرگ نباشه.دستورات زیر رو در قسمت General فرم بنویسید

Dim Image1 As IPictureDisp
Dim Image2 As IPictureDisp

Private Type Location
X As Integer
Y As Integer
End Type

Dim Image1Move As Integer
Dim Image2MoveX As Integer
Dim Image2MoveY As Integer
Dim Image1Local As Location
Dim Image2Local As Location
Const Operation = vbSrcAnd

دو تا عکس رو در مسیر برنامه کپی کنید اسمشون هم 1 و 2 باشه

کد زیر برای Form_Load هست

("Set Image1 = LoadPicture(App.Path & "\Image1.jpg
("Set Image2 = LoadPicture(App.Path & "\Image2.jpg
With me
.Show
Refresh.
.AutoRedraw = True
.ScaleMode = vbPixels
End With

Image1Move = 1
Image2MoveX = 3
Image2MoveY = 3

Do
me.PaintPicture Image1, Image1Local.X, Image1Local.Y
me.PaintPicture Image1, Image1Local.X + me.ScaleWidth, Image1Local.Y
me.PaintPicture Image1, Image1Local.X, Image1Local.Y + me.ScaleHeight
me.PaintPicture Image1, Image1Local.X + me.ScaleWidth, Image1Local.Y + me.ScaleHeight

me.PaintPicture Image2, Image2Local.X, Image2Local.Y, , , , , , , Operation
me.PaintPicture Image2, Image2Local.X + me.ScaleWidth, Image2Local.Y, , , , , , , Operation
me.PaintPicture Image2, Image2Local.X, Image2Local.Y + me.ScaleHeight, , , , , , , Operation
me.PaintPicture Image2, Image2Local.X + me.ScaleWidth, Image2Local.Y + me.ScaleHeight, , , , , , , Operation

With Image1Local
.X = .X - Image1Move
.Y = .Y - Image1Move

If .X < -me.ScaleWidth Then .X = 0
If .Y < -me.ScaleHeight Then .Y = 0
End With

With Image2Local
.X = .X - Image2MoveX
.Y = .Y - Image2MoveY

If .X < -me.ScaleWidth Then .X = 0
If .Y < -me.ScaleHeight Then .Y = 0

If .X + me.ScaleWidth > me.ScaleWidth Then .X = -me.ScaleWidth
If .Y + me.ScaleHeight > me.ScaleHeight Then .Y = -me.ScaleWidth
End With

DoEvents
Loop

برای اینکه دستورات بالا داخل یک حلقه بی پایان قرار می گیره باید در رویداد کلیک فرم بنویسید
End

فرم رو زیاد بزرگ نکنید سعی کنید تصویرها هم اندازه باشند و فرم هم اندازه تصویر ها
برای اینکه در حرکت عکس ها تنوع ایجاد کنیم در رویداد MouseMove فرم دستور زیر رو بنویسید

Image2MoveX = Int(me.ScaleWidth \ 2 - X) \ 10
Image2MoveY = Int(me.ScaleWidth \ 2 - Y) \ 10

موفق باشید

*****************************
پنج شنبه بیست و ششم 10 1387
بستن پنجره با گرفتن عنوان ان

اگر کاربر پنجره ای رو که شما تعیین می کنید رو باز کنه برنامه اون فرم رو می بنده.

در اینجا ما از دو تا تابع API استفاده می کنیم که عبارتند از : FindWindowA برای پیدا کردن پنجره مورد نظر و SetForegroundWindow برای فعال کردن پنجره مورد نظر که هر دوی این توابع در فایل user32.dll تعریف شده اند.

اول برای تعریف توابع فوق خطوط زیر رو در قسمت General وارد کنید :

Private Declare Function FindWindowA Lib "user32.dll" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Dim Temp As Long

حالا روی فرمتون یه Timer قرار بدین و خاصیت Interval اون رو به 50 تغییر بدید، بعد روی اون دابل کلیک کنید و کد های زیر رو در Sub مربوط به Timer قرار بدین:

Temp = FindWindowA(vbNullString, "My Computer")
If Temp <> 0 Then
SetForegroundWindow (Temp)
SendKeys "%{F4}"
End If

دستور اول هندل ( لازم به ذکر است که سیستم عامل به هر کنترلی و به هر فرمی شماره ای اختصاص می ده که به این شماره میگن هندل) پنجره ای رو که ( در اینجا ) عنوانش My Computer باشد رو در متغیر Temp می ریزد. شرط بعدی چک می کند که پنجره مورد نظر پیدا شده یا نه که در صورت برقراری این شرط با تابع SetForegroundWindow (که آرگومانش همون شماره ای باید باشه که با تابع FindWindowA پیدا کردیم) پنجره پیدا شده رو فعال می کنه و در نهایت تابع SendKeys زهر خودش رو می ریزه و با ارسال یک کلید میانبر به نام Alt+F4 کاربر عزیز رو در باز کردن پنجره مورد نظرش ناکام می کنه!

*******************************
بدست آوردن IP و نام سیستم میزبان

برای امروز قصد دارم یک پروژه ساده را به شما معرفی کنم.

شما ظرف چند دقیقه میتوانید این پروژه را در ویژوال بیسیک بسازید.

ابتدا ویژوال بیسیک را باز کنید سپس کنترلر های زیر را روی فرم قرار دهید :

دو عدد TextBox و دو عدد WinSock

حالا روی فرم دو بار کلیک کرده و در رویداد لود فرم کدهای زیر را وارد کنید :

Text1.Text = Winsock1.LocalIP
Text2.Text = Winsock2.LocalHostName

برنامه را اجرا کنید . این برنامه آی پی و پورت سیستم میزبان را در اختیار شما قرار میدهد.
لازم به ذکر است بعدا که به مرحله ساخت اسب های تراوا رسیدیم
خدمت شما عرض خواهم کرد که کاربرد این برنامه در هک سیستم قربانیان چیست

*******************************
پنج شنبه بیست و ششم 10 1387
سوال :دستوری می خوام که بتونم یک کلمه را توی یک فیلد بانک اطلاعاتی جستجو کنم نه اینکه اون کلمه اول نوشته باشه . این کلمه ممکنه وسط هم نوشته شده باشه

برای کاری که می خوای انجام بدی باید از دستورات SQL استفاده کنی.

اگر از کامپونت ADO استفاده می کنی دستور جستجوش به این شرحه :

Ado1.RecordSource= "Select * From [your table] Where [your field] Like ('%متن مورد نظر برای جستجو%')"

ولی اگر از کامپونت Data استفاده می کنی دستورش اینطوری می شه :

Data1.RecordSource= "Select * From [your table] Where [your field] Like ('*متن مورد نظر برای جستجو*')"

مثال : مثلا من یک Table با نام Table1 و یک فیلد به نام Address دارم و می خوام تمام آدرسهایی که توشون ( تهران ) داره پیدا کنم ، حالا این کلمه می خواد هرجایی از فیلد باشه :

Ado1.CommandType = adCmdText

Ado1.RecordSource= "Select * From Table1 Where Address Like ('%تهران%')"

Ado1.Refresh
*******************************
بستن پنجره با گرفتن عنوان ان

اگر کاربر پنجره ای رو که شما تعیین می کنید رو باز کنه برنامه اون فرم رو می بنده.

در اینجا ما از دو تا تابع API استفاده می کنیم که عبارتند از : FindWindowA برای پیدا کردن پنجره مورد نظر و SetForegroundWindow برای فعال کردن پنجره مورد نظر که هر دوی این توابع در فایل user32.dll تعریف شده اند.

اول برای تعریف توابع فوق خطوط زیر رو در قسمت General وارد کنید :

Private Declare Function FindWindowA Lib "user32.dll" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Dim Temp As Long

حالا روی فرمتون یه Timer قرار بدین و خاصیت Interval اون رو به 50 تغییر بدید، بعد روی اون دابل کلیک کنید و کد های زیر رو در Sub مربوط به Timer قرار بدین:

Temp = FindWindowA(vbNullString, "My Computer")
If Temp <> 0 Then
SetForegroundWindow (Temp)
SendKeys "%{F4}"
End If

دستور اول هندل ( لازم به ذکر است که سیستم عامل به هر کنترلی و به هر فرمی شماره ای اختصاص می ده که به این شماره میگن هندل) پنجره ای رو که ( در اینجا ) عنوانش My Computer باشد رو در متغیر Temp می ریزد. شرط بعدی چک می کند که پنجره مورد نظر پیدا شده یا نه که در صورت برقراری این شرط با تابع SetForegroundWindow (که آرگومانش همون شماره ای باید باشه که با تابع FindWindowA پیدا کردیم) پنجره پیدا شده رو فعال می کنه و در نهایت تابع SendKeys زهر خودش رو می ریزه و با ارسال یک کلید میانبر به نام Alt+F4 کاربر عزیز رو در باز کردن پنجره مورد نظرش ناکام می کنه!

*******************************
پنج شنبه بیست و ششم 10 1387
توابع SaveSetting و GetSetting

» وقتی شما برنامه ای مانند ویژوال بیسیک را اجرا می کنید و در محیط کاری آن تغییراتی ایجاد می نمایید ، این تغییرات برای اجرای بعدی برنامه ثبت می شوند . برای مثال اگر شما ToolBox وی بی را مخفی کنید در اجرای بعدی آن ToolBox نمایش داده نخواهد شد . این امر در بسیاری از برنامه های دیگر نیز صدق میکند . این تغییرات که در اصطلاح ( Setting ) نام دارند یا در رجیستری یا در یک فایل ذخیره می شوند . خود VB این تغییرات را در رجیستری ثبت میکند و هنگام اجرا محیط خود را بر اساس این داده ها تنظیم می نماید .

» هنگامی که کلمه رجیستری در VB به گوش برنامه نویسان می رسد سریع ذهن آنها را متوجه توابع پیچیده API مربوط به کار با رجیستری می کند . برای همین من امروز می خواهم روش ذخیره کردن تنظیمات یک برنامه در رجیستری را بدون استفاده از توابع پیچیده مخصوص کار با رجیستری به وسیله دو تابع بسیار ساده مخصوص این کار به شما معرفی کنم :

» تابع SaveSetting : برای ساخت کلید و ذخیره کردن اطلاعات در رجیستری .

( SaveSetting ( AppName As String , Section As String , Key As String , Setting As String

_ AppName : این پارامتر مشخص کننده نام برنامه ( پروژه ) است . البته هر نوشته دیگری هم می تواند باشد که نام کلید اصلی در رجیستری را مشخص می کند .

_ Section : این پارامتر نا کلید زیر شاخه است که بیشتر از نام Setting برای آن استفاده می کنند .

_ Key : این پارامتر مشخص کننده نام کلید از نوع String است که داده ها در آن ذخیره می شوند .

_ Setting : این پارامتر هم که اصلی ترین بخش است همان داده یا مقداری است که در کلید ذخیره می شود .

» برای مثال : تابع با پارامتر های ورودی زیر مقدار رشته ( "1" ) را در کلید SampleKey ذخیره می کند .

"SaveSetting "Test" , "Setting" , "SampleKey" , "1

_ شاید از خودتان بپرسید که مسیر این کلید در رجیستری چگونه است . کلیه این کلیدها و مقادیر که ایجاد می شوند در آدرس زیر قرار می گیرند و ما نمی توانیم از آدرس دیگری استفاده نماییم :

\HKEY_CURRENT_USER\Software\VB and VBA Program Settings

در مثال قبلی مقادیر در شاخه زیر ذخیره می شوند که شما می توانید با مراجعه به آن به این مطلب پی ببرید :

HKEY_CURRENT_USER\Software\VB and VBA Program Settings\Test\Setting

» تابع GetSetting : برای خواندن اطلاعات از رجیستری .

(GetSetting ( AppName As String , Section As String , Key As String , Setting As String

_ پارامتر های این تابع به جز گزینه آخر که در این تابع جایی ندارد دقیقا شبیه به هم هستند :

( " KeyValue = GetSetting ( " Test" , "Setting" , "SampleKey

_ در این مثال مقدار ( 1 ) را که قبلا با تابع قبلی در کلید SampleKey قرار دادیم درون متغیر KeyValue قرار می گیرید .

» برنامه نمونه : حال می خواهیم برنامه جالبی با استفاده از این توابع معرفی شده بنویسیم .

شرح برنامه : می خواهیم برنامه ای بنویسیم که دارای تعداد مشخص اجرا باشد . یعنی کاربر فقط بتواند پنج بار این برنامه را اجرا کند و در هر بار اجرای آن پیغامی مبنی بر تعداد باقیمانده دفعات اجرا برای کاربر نمایش داده شود و هنگامی که این تعداد به پایان رسید پیغامی نمایش داده شود که دیگر کاربر نمی تواند این برنامه را اجرا نماید . مانند برنامه هایی که دارای قفل یا به اصطلاح رجیستری هستند .

_ برای این کار شما فقط کافی است کدهای زیر را در Form_Load برنامه خود قرار دهید :

()Private Sub Form_Load
Dim RunCount As String
( "RunCount = GetSetting("Test", "Setting", "RunCount
If Val(RunCount) > 5 Then

_,"مهلت اجرای برنامه به پایان رسیده و شما دیگر قادر به اجرای آن نخواهید بود"MsgBox vbExclamation , "اتمام مهلت"

End
Else

_ ,"شما فقط " & ((Str(4 - Val(RunCount & " بار دیگر می توانید این برنامه را اجرا کنید" MsgBox

vbInformation, "تعداد اجرای باقیمانده"

(SaveSetting "Test", "Setting", "RunCount", Str(Val(RunCount) + 1
End If
End Sub

حال فایل exe از برنامه خود بسازید و آن را اجرا نمایید

*******************************
پنج شنبه بیست و ششم 10 1387
کتابچه سورس

یکی از راههای اینکه شما بتونید روش کد نویسی رو خوب یاد بگیرید و یا از کدهای استاندارد و از پیش نوشته شده در برنامه هاتون به خوبی استفاده کنید اینه که از کدهای نوشته شده کتابها استفاده کنید. به همین دلیل هم به دوستان عزیز پیشنهاد می کنم برای این منظور به سایت انتشارات Wrox سر بزنن و از هر کتابی که دلشون میخواد هر سورسی رو دوست دارن بردارن. شما می تونید از کدهای اونها که واقعاً با توضیحات خوب نوشته شدن استفاده کنید. برای این منظور به این ادرس بروید
http://www.wrox.com/dynamic/books/download.aspx

*******************************
نحوه تولید DLL با ویژوال بیسیک

بعنوان یک زبان برنامه‌نویسی با توسعه سریع، ویژوال بیسیک نظر خیلی از برنامه‌نویسان را از جهت سادگی به خود معطوف کرد. برنامه‌نویسی با ویژوال بیسیک در کمترین زمان صورت می‌گیرد حال آنکه در مقابل زبانهایی چون C و ++C اغلب اوقات به روزها کار مفید نیاز است.
اما بیشترین انتقادی که برنامه‌نویسان از ویژوال بیسیک دارند در این است که قادر به تولید کتابخانه‌های پویا (DLL) نیست. حقیقتا این نظر مورد قبول است که نمی‌توان این نوع فایلها را در کنار فایلهای اجرایی(Exe) یا ActiveX Exe تولید کرد.
در این مقاله ما قصد داریم که نگاه دقیقی به نحوه تولید فایلهای اجرایی در ویژوال بیسیک یندازیم و بعد با طی مراحل ساده‌ای موفق به ایجاد فایلهای DLL بشویم تا از زیر بار این انتقاد نیز رهایی یابیم.
قبلا به این موضوع اشاره شد که فایهای DLL آن دست از برنامه‌هایی هستند که یکبار نوشته می‌شوند و در پروژه‌های بعدی بکرات می‌تواند از آنها استفاده برد. چیزی که هسته ویندور را تشکیل می‌دهد اینگونه فایلها هستند. علاوه بر آن تکنیک‌هایی وجود دارد که شما را قادر می‌سازد تا برنامه‌هایی بنویسید که قادرند خود را بروز برسانند و یا خود ترمیم باشند. بهتر از آن اینکه برنامه‌ای بنویسید که با الحاق اینگونه فایلها بدان قدرت و امکانات جدید بدان افزود. همانند نرم‌افزارهای رایج از جمله Winamp.

کتابخانه‌های پویای قابل اتصال (DLL) چه هستند؟

یک DLL مجموعه‌ای از توابع و پروسه‌هایی است که می‌تواند از برنامه یا DLLهای نظیر خود فراخوانده شود.

استفاده از اینگونه کتابخانه‌های دو مزیت اصلی دارد:
1- امکان به اشتراک گذاری از کد را فراهم می‌سازند. یک DLL می‌تواند مورد استفاده خیلی از برنامه‌های قرار گیرد. بعنوان مثال کتابخانه Win32 API نمونه‌ای از این سری فایلها است. بعلاوه از زمانی که پروسه‌های گوناگون قادر به فراخوانی یک DLL واحد هستند امکان به اشتراک گذاری کد‌ها و روتین‌ها فراهم آمده است. یک فایل DLL تنها یکبار به درون حافظه لود می‌شود و بارها توسط پروسه‌های گوناگونی مورد استفاده قرار می‌گیرد و این یعنی مدیریت حافظه بهتر.

2- مزیت دیگر امکان نوشتن برنامه‌ها بصورت اجزای منفصل است که این اجزا خود قابل تعویض با نگارش‌های جدیدتر جهت توسعه نرم‌افزار خواهند بود بدون اینکه خطی از کد برنامه اصلی دگرگون شود.

با این توصیف فایلهای کتابخانه‌ای درونی که در پروژه‌های مورد استفاده قرار می‌گیرد در صورت تغییر نیاز هست تا پروژه اصلی دوباره کمپایل شود تا بتوان با آن ارتباط بر قرار کرد. اما در DLL ها چون بصورت پویا و قابل انعطاف نوشته شده‌اند این اتصال در بیرون از بدنه اصلی و درست در زمان فراخوانی آن قبیل از متدها و توابع شکل می‌گیرد و این خود تفاوت آشکار از مزیت این گونه از فایلها می‌باشد.همچنین یک فایل DLL می‌تواند حاوی توابعی باشد که فقط مورد استفاده خود هست و از درون به آن دسترسی نخواهیم داشت و آندسته از تابعی را که نیاز هست معرفی می‌کنیم تا از بیرون بدان دسترسی داشته باشیم. در این مرحله نیاز به معرفی در فایلهای Def هست که در پروژه‌های C و C++ مورد استفاده قرار می‌گیرد.

و اما ساختار DLL
فایلهای DLL حاوی یک مدخل شروع انتخابی (optional entry point) و پایانی هستند که در زمانی که توسط برنامه‌های دیگر به درون حافظه لود یا آنلود می‌شوند قابل اجرا است. ویندوز این پروسه را در زمانی که یک برنامه DLLها را بدرون حافظه لود یا آنلود می‌کند اجرا می‌کند.
این دو نوع پروسه به DLL این امکان را می‌دهد که یک سری از مقدمات را پیش از استفاده مهیا کند یا بعد از استفاده پاکسازی نماید. در ویژال بیسیک این تابع بدین گونه تعریف می‌شود:

Public Function DllMain(hinstDLL As Long, fdwReason As Long , lpwReserved As Long) As Boolean

که پارامترهای آن بدین قرارند:
hInstDLL که حاوی یک مقدار یکتا بعنوان دستگیره فایل DLL است.
fdwReason مشخص کننده دلیل فراخوانی این پروسه توسط سیستم‌عامل است که یکی از چهار مقدار زیر را به خود منتصب می‌کند:
DLL_PROCESS_ATTACH (1): یک پروسه در حال لود DLL به دورن حافظه است. هر پیش‌نیاز باید در اینجا شکل گیرد.
DLL_THREAD_ATTACH (2): یک ریسمان (Thread) برای این DLL در حال تولید است. هر پیش‌نیاز برای ایجاد ریسمان در این مرحله می‌تواند شکل بگیرد.
DLL_THREAD_DETACH (3) ریسمان در حال پایان یافتن است. به منظور پاک‌سازی DLL از حافظه.
DLL_PROCESS_DETACH (0) فایل DLL در حال خروح از حافظه است. بمنظور پاک‌سازی سایر کارها توسط برنامه‌نویس امکان انجام در این مرحله فراهم آمده است.

lpvReserved: حاوی مقدار اضافی در استفاده از DLL_PROCESS_ATTACH یا DLL_PROCESS_DETACH می‌باشد.
مقدار برگشتی تابع DllMain در هنگام صدا زدن بصورت DLL_PROCESS_ATTACH مقدار TRUE را باید به خود بگیرد.

در تلاش برای تولید و توسعه یک DLL نمونه قصد این را داریم که یک کتابخانه ریاضی تشکیل دهیم. کد زیر در ماژولی بنام MathLib.Bas قرار می‌گیرد:

Option Explicit
Public Const DLL_PROCESS_DETACH = 0
Public Const DLL_PROCESS_ATTACH = 1
Public Const DLL_THREAD_ATTACH = 2
Public Const DLL_THREAD_DETACH = 3


Public Function DllMain(hInst As Long, fdwReason As Long, lpvReserved As Long) As Boolean
Select Case fdwReason
Case DLL_PROCESS_DETACH
' No per-process cleanup needed
Case DLL_PROCESS_ATTACH
DllMain = True
Case DLL_THREAD_ATTACH
' No per-thread initialization needed
Case DLL_THREAD_DETACH
' No per-thread cleanup needed
End Select
End Function


Public Function Increment(var As Integer) As Integer
If Not IsNumeric(var) Then Err.Raise 5

Increment = var + 1
End Function


Public Function Decrement(var As Integer) As Integer
If Not IsNumeric(var) Then Err.Raise 5

Decrement = var - 1
End Function


Public Function Square(var As Long) As Long
If Not IsNumeric(var) Then Err.Raise 5

Square = var ^ 2
End Function
*******************************
پنج شنبه بیست و ششم 10 1387
چگونه مسیر نصب ویندوز را پیدا کنیم :

Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Public Function WinDir() As String
Dim Wind As String
Wind = Space(500)
Wind = Left(Wind, GetWindowsDirectory(Wind, Len(Wind)))
WinDir = Wind
End Function

*******************************
یکی از دوستان سوال کرده بودند که "چه جوری میشه برنامه خودشو کپی کنه تو فولدر StartUp ویندوز؟"
خوب شما باید از دستور FileCopy استفاده کنید به این ترتیب:

FileCopy App.Path + "\" + App.EXEName + ".exe", "Windows Drive\Documents and Settings\User Name\Start Menu\Programs\Startup" + "\" + App.EXEName + ".exe" 'Copy Function

در این دستور که دستور کپی میباشد به جای:
Windows Drive درایو ویندوز را قرار دهید

User Name نام کاربر را بنویسید البته میتوانید از کلمه All Users نیز استفاده کنید که مخصوص تمام کاربران میباشد(نتیجه این کار را پس از رستارت میبینید)

در اینجا :

App.Path یعنی از درایو تا فولدر برنامه
App.EXEName یعنی نام فایل برنامه
".exe" به دلیل اینکه پسوند فایل نیز به دستور اضافه شود میباشد

*******************************
ساختن جدول در بانک اطلاعاتی

از منوی project گزینه refrences رو انتخاب کنید - بعد اونجا گزینه Microsoft ActiveX Data Objects 2.0 library پیدا کنیدو تیک بزنید - Adodc مورد نظرتون رو هم با دیتابیس set کنید - بعد :

Dim db_file As String
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim NumRec As Integer

Set conn = New ADODB.Connection
conn.ConnectionString = Adodc1.ConnectionString
conn.Open

On Error Resume Next
conn.Execute "DROP TABLE Jadid"
On Error GoTo 0

conn.Execute "CREATE TABLE Jadid(" & "One INTEGER NOT NULL," & "Two VARCHAR(40) NOT NULL," & "Three VARCHAR(40) NOT NULL)"

conn.Execute "INSERT INTO Jadid VALUES (1,'4','7')"
conn.Execute "INSERT INTO Jadid VALUES (2,'5','8')"
conn.Execute "INSERT INTO Jadid VALUES (3,'6','9')"

Set rs = conn.Execute("SELECT COUNT (*) FROM Jadid")
NumRec = rs.Fields(0)

conn.Close

MsgBox "Created ... "

*******************************
پنج شنبه بیست و ششم 10 1387
زیر نظر گرفتن تغییرات یک شاخه یا زیر شاخه

با گوگل دسک‌تاپ کار کردید؟ اگر نه که پیشنهاد می‌کنم حتما یکبار امتحان کنید تا به ارزشش پی ببرید. با برنامه‌هایی که در پشت پرده عمل ایندکس‌گذاری فایلها رو انجام می‌دهند چی، آشنا هستید؟ منظور برنامه‌هایی که کار جستجو رو راحت می‌کنند تا کاربر سریع‌تر به جستجوی فایلها بپردازد. آیا اینگونه برنامه‌ها بطور مداوم باید فایلها و پوشه‌ها رو زیر نظر داشته باشند تا به محض رؤیت تغییر جدید، بانک خود را اصلاح کنند؟ اگر بدین شکل باشد که این کار پردازنده را زیر بار می‌برد، نه؟
حالا اگر این کار در بطن سیستم‌عامل نهفته باشد و به محض تغییر محتویات اعم از ایجاد و حذف فایل، تغییر فایل، تغییر خصلت فایل، اندازه و ... در مسیری به ما اطلاع داده شود، کار ما ساده‌تر شده و بار زیادی هم از روی دوش پردازنده برداشته می‌شود. سورس زیر رو ببینید تا بطور عملی در نحوه استفاده از این قبیل توابع آشنا شوید.

http://h1.ripway.com/PalizeSoftware/Files/watchdir.rar

*******************************
فیلتر کردن بعضی از کلید های صفحه کلید

Private Sub Form_KeyPress(KeyAscii As Integer)
Dim svalid As String
svalid = "0123456789"
If InStr(svalid, Chr(KeyAscii)) = 0 Then
KeyAscii = 0
MsgBox "Not valid Keys.please Press 0-9 keys"
End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
MsgBox "The form cannot be close.farzad dh."
Dim leftI As Long
Dim rightI As Long
leftI = Form1.Left + 1000
rightI = Form1.Top + 1000
Dim a As New Form1
a.Width = Me.Width
a.Height = Me.Height
a.Left = leftI
a.Top = rightI
a.Show
End Sub
*******************************
یک کار جالب با موس

فقط یک تایمر با زمان 500 روی فرم قرار بدین و این کدها رو داخلش کپی کنید
Dim farzadvb
Dim bestforvb6
Dim temp
Randomize 1000

farzadvb = Rnd(10) * 1000

bestforvb6 = Rnd(10) * 1000

temp = SetCursorPos(farzadvb, bestforvb6)

********************************
چگونه متن داخل یک TextBox را Select کنیم :

Private Sub Text1_GotFocus()
Text1.SelStart = 0
Text1.SelLength = Len(Text1)
End Sub

*******************************
پنج شنبه بیست و ششم 10 1387
تبدیل به سطوح خاکستری (GrayScale)

امروز برای شما سورسی رو تدارک دیدم که بتونید تصاویر رنگی رو به تصاویر خاکستری (GrayScale) تبدیل کنید.
در واقع تبدیل یک پیکسل رنگی به طرح خاکستری خیلی راحت صورت می‌گیرد.
می‌دونیم که هر رنگ دارای سه مؤلفه قرمز، سبز و آبی است. برای تبدیل به طرح خاکستری کافیه که رنگ قرمز رو در ضریب 0.3، سبز رو در ضریب 0.59 و آبی رو در ضریب 0.11 ضرب کنید.
در آینده شما رو با تکنیک‌های دیگه‌ای در زمینه گرافیک آشنا خواهم کرد. پس چه بهتر که شما بفرمائید در چه زمینه‌هایی مشتاق هستید بدونید

http://h1.ripway.com/PalizeSoftware/Files/GrayScale.rar

*******************************
فایلهای Zip

قابلیت فشرده‌سازی و استخراج فایلهای فشرده (در نوع ZIP) رو به نرم‌افزارهای خود اضافه کنید یه خبر قابل دانلود دارم. فایل زیر که بصورت API مورد استفاده قرار می‌گیره (اصل موضوع همینه که می‌تونید در هر نرم‌افزاری که قابلیت فراخوانی توابع API‌ رو داره بکار بگیرید.) قادره با سرعت بالا (وحشتناک و غیر قابل تصور) اقدام به فشرده‌سازی و استخراج این قبیل فایلها بپردازه.
حتی قادرید مشخص کنید که از چه نوع فشرده‌سازی استفاده کنه. ضمن اینکه قادرید بصورت CallBack‌ پیشرفت کارش رو هم تحویل بگیرید یعنی خیلی برنامه‌نویس رو تحویل گرفته‌اند که این رو هم نوشته‌اند!
نکته آخر اینکه این موضوع رو (با همین عنوان) قبلا در سایت برنامه‌نویس قرار داده بودم و برای دوستانی که ممکنه ندیده باشند، اینجا هم گذاشتم

http://h1.ripway.com/PalizeSoftware/files/bszipdll.zip
پنج شنبه بیست و ششم 10 1387
معرفی هیستوگرام تصویر و چگونگی تهیه آن

شبیه سازی نمودار هیستوگرام در فتوشاپ
هیستوگرام مشخص کننده میزان روشنایی یا تیرگی تصویر هست.
به عبارتی تعداد پیکسل‌های تصویر ما را در بازه‌ای از دو رنگ تیره(مشکی) و روشن(سفید) مشخص می‌کند، یعنی همان نمودار فراوانی رنگ پیکسل‌ها.
در سطوح حرفه‌ای برای یک عکاس این نمودار حائز اهمیت است، چرا که به روشنی یا تیرگی عکس پی می‌برد. امروزه دوربین‌های دیجیتال سطح بالا قادر هستند تا بعد از شکار عکس، نمودار هیستوگرام آنرا نمایش دهند.
سورس زیر این نمودار را بر اساس همین روش پیاده کرده و هیستوگرام مربوطه را با قابلیت تفکیک کانال‌های قرمز، سبز و آبی به نمایش می‌گذارد

http://h1.ripway.com/PalizeSoftware/Files/Histogram.zip

*******************************
تبدیل به سطوح خاکستری (GrayScale)

امروز برای شما سورسی رو تدارک دیدم که بتونید تصاویر رنگی رو به تصاویر خاکستری (GrayScale) تبدیل کنید.
در واقع تبدیل یک پیکسل رنگی به طرح خاکستری خیلی راحت صورت می‌گیرد.
می‌دونیم که هر رنگ دارای سه مؤلفه قرمز، سبز و آبی است. برای تبدیل به طرح خاکستری کافیه که رنگ قرمز رو در ضریب 0.3، سبز رو در ضریب 0.59 و آبی رو در ضریب 0.11 ضرب کنید.
در آینده شما رو با تکنیک‌های دیگه‌ای در زمینه گرافیک آشنا خواهم کرد. پس چه بهتر که شما بفرمائید در چه زمینه‌هایی مشتاق هستید بدونید

http://h1.ripway.com/PalizeSoftware/Files/GrayScale.rar

*******************************
پنج شنبه بیست و ششم 10 1387
ضبط صدا به فرمت دلخواه با ویژوال بیسیک

با این برنامه‌ به فرمت دلخواه صدا را ضبط کنید. آن هم به شکلی خیلی ساده.
راه‌های زیادی برای رسیدن به ضبط صدا هست! اما هدف من در اینجا ضبط صدا به فرمت دلخواه است، مثلا mp3 و بدون استفاده از ابزارهای برنامه‌نویسی نظیر ActiveX و ...
ما می‌خواهیم با استفاده از توابع API‌ به این هدف برسیم. توابع در دسترس برای پخش و ضبط صدا عبارتند از mciSendString، mciSendCommand و mciExecute. (برای آشنا شدن با این توابع می‌توانید به سراغ MSDN بروید.)
این توابع هر کدام پیچیدگی خاص خودشان را دارند. مخصوصا اگر قصد ضبط صدا را داشته باشید که باید پارامترهای زیادی را تنظیم کنید که نرخ‌نمونه برداری، تعداد کانال صوتی، بافر و ... را شامل میشوند.
من قصد دارم شما را با تابع mciSendCommand آشنا کنم که با وجود پیچیدگی بیش از حد، استفاده راحت‌تری از آن هم میسر هست و البته به طریقی که آموزش می‌دهم.
بهتر هست با یک مثال شروع کنیم:
شکل کلی این تابع این چنین هست:

Public Declare Function mciSendCommand Lib "winmm.dll" _
Alias "mciSendCommandA" (ByVal wDeviceID As Long, _
ByVal uMessage As Long, _
ByVal dwParam1 As Long, _
ByVal dwParam2 As Any) As Long

پخش فایل صوتی شامل چند مرحله است:
1- باز کردن فایل صوتی
2- دستور پخش
3- بستن فایل (که حتما باید انجام بشه)
باز کردن فایل صوتی خود شامل پارامترهایی است که در ساختار زیر مشخص میشود:

Private Type MCI_OPEN_PARMS
dwCallback As Long
wDeviceID As Long
lpstrDeviceType As String
lpstrElementName As String
lpstrAlias As String
End Type

البته باید ذکر کنم که برخی پارامترها در شرایط خاصی مقدار دهی می‌شوند تا کار مشخصی را انجام دهند (پارامتر سوم، بعدا مثال میآرم)
کد زیر یک فایل صوتی را باز می‌کند و هندل آن را در صورت موفقیت جایی نگه می‌داریم، چون از این به بعد ما با این هندل خیلی کار داریم.
پارامتر آخر از تابع mciSendCommand حاوی ساختار مرتبط با نحوه عمل است.

Dim dwReturn As Long
Dim mciOpenParms As MCI_OPEN_PARMS
'Open a waveform-audio device with filename for play.
mciOpenParms.lpstrDeviceType = "WaveAudio"
mciOpenParms.lpstrElementName = filename dwReturn = mciSendCommand(0, MCI_OPEN, _
MCI_OPEN_ELEMENT Or MCI_OPEN_TYPE, _
mciOpenParms)
If dwReturn Then
MsgBox "Failed to open device; don't close it, just return error."
Exit Sub
End If 'The device opened successfully; get the device ID.
wDeviceID = mciOpenParms.wDeviceID

و برای پخش از کد زیر استفاده می‌کنیم که بعد از کد باز کردن فایل میگذاریم:

dwReturn = mciSendCommand(wDeviceID, MCI_PLAY, 0, vbNull)
If dwReturn Then
mciSendCommand wDeviceID, MCI_Close, 0, vbNull
MsgBox "MCI_PLAY not succed!"
Exit Sub
End If

اگر دقت کنید پارامتر سوم مقدار صفر را داراست. این پارامتر می‌تواند به نحوی مشخص شود که با اجرای دستور پخش، کنترل به برنامه داده شود یا تا زمانی که پخش به اتمام نرسیده برنامه منتظر بماند. و مشخه‌های دیگر.
چون ذکر نکردیم پس کنترل برنامه را در حین پخش در دست می‌گیریم.
و سرانجام با این کد فایل را می‌بندیم:

Dim dwReturn As Long dwReturn = mciSendCommand(wDeviceID, MCI_Close, MCI_WAIT, vbNull)
If dwReturn Then
mciSendCommand wDeviceID, MCI_Close, 0, vbNull
MsgBox "MCI_Close not succed!"
Exit Sub
End If

و اما ضبط صدا. برای ضبط باید از ساختار پیچیده زیر استفاده کنیم:

Private Type MCI_WAVE_SET_PARMS
dwCallback As Long
dwTimeFormat As Long
dwAudio As Long
wInput As Long
wOutput As Long
wFormatTag As Integer
wReserved2 As Integer
nChannels As Integer
wReserved3 As Integer
nSamplesPerSec As Long
nAvgBytesPerSec As Long
nBlockAlign As Integer
wReserved4 As Integer
wBitsPerSample As Integer
wReserved5 As Integer
End Type

برای یک ضبط ساده باید این همه پارامتر را مقدار دهی کنید و تازه ممکن است صدا بر اساس مقادیر اشتباه بی کیفیت و نامطلوب ضبط شود.
از همه اینها که بگذریم قصد من این بود تا ترفندی را به شما آموزش بدهم که خیلی راحت صدا را به هر فرمتی که خواستید ضبط کنید.

.:: CODEC ::.
این کلمه مخفف واژه‌های COmpress/DECompress هست و به زبان ساده‌تر درایوری است که عمل کدسازی و دیکودسازی اطلاعات را انجام می‌دهد، البته برای کاربر محسوس نیست و به نوعی در پشت پرده انجام می‌گیرد.
وقتی شما فایلهای wav را در سیستم پخش می‌کنید، باید codec فایلهای wav در سیستم نصب شده باشد وگرنه قادر به پخش نیستید که البته بهمراه ویندوز این درایورها نصب میشوند.
برای فایلهای mp3 نیز همین قضیه صادق هست و غیره.
برای اینکه بدانید بر روی سیستم شما چه codecهایی نصب شده مراحل زیر را دنبال کنید:

Control Panel -> Sound & Audio Device -> Hardware -> select Audio Codec from list -> click on Properties.

با این توضیحاتی که آمد می‌خواهیم بر اساس یکی از codecهای نصب شده اقدام به ضبط صدا کنیم.
لازم به ذکر است که برخی codecها فقط حاوی بخش پخش هستند و امکان ضبط رو ندارند!
برسیم به هدف اصلی از این صحبت‌ها.

1- Sound Recorder ویندوز رو باز کنید و سپس از منوی File گزینه Save As...‌ را انتخاب کنید.
2- دکمه Change را کلیک کنید تا لیست codec ها ظاهر شود.
3- گزینه Format را با codecی که می‌خواهید تنظیم کنید.
4- OK کنید و بعد نام فایل را مشخص کنید و Save‌ نمائید.

با طی این 4 مرحله شما یک فایل صوتی ساختید که فقط حاوی تنظمیات صدا است. یعنی تمام پارامترهای ساختار MCI_WAVE_SET_PARMS

حالا اگر با تابع mciSendCommand‌ این فایل را باز کنید و اقدام به ضبط صدا نمائید، در واقع دارید به فرمتی که می‌خواهید صدا را ضبط می‌کنید و درگیر تنظیمات خاصی نیستید.
سورسی را که مربوط به همین بخش است، این صحبت‌ها را پیاده‌سازی کرده و نمونه کاملی از ضبط و پخش به فرمت دلخواه را انجام می‌دهد.
و این نکته که دو فایل با پسوند mrf در کنار برنامه هست، در واقع فایل‌های حاوی ساختار هستند(wav)‌ که پسوندشان عوض شده.

برنامه ابتدا لیست تمام فایلهای با پسوند mrf‌ را لیست می‌کند و در هنگام ضبط به همان فرمتی که انتخاب می‌کنید اقدام به ضبط می‌کند.
شما می‌توانید هر ساختاری را که دوست داشتید با Sound Recorder بسازید و با پسوند mrf در کنار برنامه ذخیره کنید و از نزدیک با چگونگی عمل ضبط آشنا شوید.

http://h1.ripway.com/PalizeSoftware/Files/WaveRecordTest.zip
پنج شنبه بیست و ششم 10 1387
X